home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
ngenerics.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
17KB
|
670 lines
/*
* New Generic function interface for feel
*
*/
/*
functions:
generic_apply (gf, arglist)
call_method(meth, sig, args)
set_compute_function(lisp function)
sundry accessors
This approach has lots of advantages....
if generic_apply fails, we call the function
'compute_and_apply_method' which should
1) calculate method to apply
2) stash the method in a cache
3) call it via call_method
*/
/*
Data structures:
A table is a cons structure for accessing via a list
format:
fast cache: (last-method-call-sig result)
slow cache: table of methods, keying (sig+methods)
--- keep the sig as we don't want to recontruct it.
*/
#include "structs.h"
#include "defs.h"
#include "funcalls.h"
#include "global.h"
#include "allocate.h"
#include "ngenerics.h"
#include "bootstrap.h"
#include "class.h"
#include "table.h"
#include "bvf.h"
#include "modules.h"
#include "symboot.h"
#include "specials.h"
#include "modboot.h"
#include "calls.h"
#include "vectors.h"
static LispObject sym_signature;
static LispObject sym_qualifiers;
static LispObject sym_lambda_list;
static LispObject sym_method_class;
static LispObject method_status_handle;
static LispObject method_args_handle;
static LispObject generic_compute_discriminating_function;
static LispObject generic_add_method;
static EUFUN_1( Fn_generic_function_p, obj)
{
return((is_generic(obj) ? lisptrue : nil));
}
EUFUN_CLOSE
static EUFUN_1( Fn_methodp, obj)
{
return((is_method(obj) ? lisptrue : nil));
}
EUFUN_CLOSE
/* Time waster functions */
LispObject generic_apply_4(LispObject *stacktop, LispObject gf,
LispObject a1, LispObject a2,
LispObject a3, LispObject a4)
{
LispObject *stackbase=stacktop;
STACK_TMP(a1); STACK_TMP(a2); STACK_TMP(a3); STACK_TMP(a4);
return(generic_apply(stackbase,gf));
}
LispObject generic_apply_3(LispObject *stacktop,LispObject gf,
LispObject a1, LispObject a2, LispObject a3)
{
LispObject *stackbase=stacktop;
STACK_TMP(a1); STACK_TMP(a2); STACK_TMP(a3);
return(generic_apply(stackbase,gf));
}
LispObject generic_apply_2(LispObject *stacktop,LispObject gf,LispObject a1, LispObject a2)
{
LispObject *stackbase=stacktop;
STACK_TMP(a1); STACK_TMP(a2);
return(generic_apply(stackbase,gf));
}
LispObject generic_apply_1(LispObject *stacktop, LispObject gf,
LispObject a1)
{
LispObject *stackbase=stacktop;
STACK_TMP(a1);
return(generic_apply(stackbase,gf));
}
LispObject generic_apply(LispObject *stackbase,LispObject gf)
{
static LispObject compute_and_apply_method(LispObject *);
static LispObject call_method(LispObject *,int,LispObject);
LispObject *stacktop, *walker;
LispObject ptr,args,fastcache;
int count, nargs,explicit,extras;
if (intval(generic_argtype(gf)) >= 0) {
explicit = intval(generic_argtype(gf));
extras = FALSE;
}
else {
explicit = -intval(generic_argtype(gf))-1;
extras = TRUE;
}
nargs=explicit+(extras ? 1 : 0);
stacktop=stackbase+nargs;
/* fast cache first */
fastcache=(generic_fast_method_cache(gf));
ptr=CAR(fastcache); /* nb car(nil)==nil */
/* is there a cache ? */
if (ptr!=nil)
{
/** Method lookup **/
walker=stackbase;
count=0;
while (count<explicit && CAR(ptr)==classof(*(walker)))
{
ptr=CDR(ptr);
walker++;
count++;
}
if (count==explicit)
return(call_method(stackbase,nargs,
CDR(fastcache)));
/* then the slow cache */
ptr=generic_slow_method_cache(gf);
walker=stackbase;
count=0;
while(ptr!=nil && count<explicit)
{
if (CAR(CAR(ptr))==classof(*(walker)))
{ /* move down 1 */
ptr=CDR(CAR(ptr));
walker++;
count++;
}
else
ptr=CDR(ptr);
}
if (count==explicit)
{
generic_fast_method_cache(gf)=ptr;
return(call_method(stackbase,nargs,CDR(ptr)));
}
/* not in slow cache */
}
STACK_TMP(gf);
/** find Args **/
args=allocate_n_conses(stacktop,nargs);
ptr=args;
walker=stackbase;
count=0;
while (count<nargs)
{
CAR(ptr)= *walker;
ptr=CDR(ptr);
++walker;
++count;
}
UNSTACK_TMP(gf);
return(EUCALL_2(compute_and_apply_method,gf, args));
}
LispObject call_method(LispObject *stackbase, int nargs, LispObject ml)
{
LispObject mf;
if (!is_method(CAR(ml)))
CallError(stackbase,"call-method: Not a method\n",nil,NONCONTINUABLE);
mf = method_function(CAR(ml));
if (is_c_function(mf)) {
return((mf->C_FUNCTION.func)(stackbase));
}
/* Should we check the arity of the function --- no add method should. */
if (is_i_function(mf) || is_e_function(mf))
{ /* Should I make the env and apply here ? */
LispObject *walker,*stacktop;
LispObject args,ret,ptr;
int count;
stacktop=stackbase+nargs;
STACK_TMP(mf);
STACK_TMP(CDR(ml));
/* one method list, one arg list */
args=allocate_n_conses(stacktop,nargs+2);
UNSTACK_TMP(ml);
CAR(args)=ml; /* Arg 1: arg list */
ptr=CDR(args);
CAR(ptr)=CDR(ptr); /* Arg 2: Arguments */
ptr=CDR(ptr);
walker=stackbase;
count=0;
while (count<nargs)
{
CAR(ptr)= *walker;
ptr=CDR(ptr);
++walker;
++count;
}
UNSTACK_TMP(mf);
stackbase=stacktop;
EUCALLSET_2(ret,module_mv_apply_1,mf,args);
return ret;
}
/* if (is_b_function(mf))
return(apply_nary_bytefunction(stackbase,nargs,ml));
*/
CallError(stackbase,
"call method: unknown method function class",mf,NONCONTINUABLE);
return(nil);
}
/* repeat of last, but with args passed in a list this time... */
static EUFUN_2(call_method_by_list,ml , args)
{
LispObject mf;
if (!is_method(CAR(ml)))
CallError(stacktop,"Not a method\n",nil,NONCONTINUABLE);
mf = method_function(CAR(ml));
if (is_i_function(mf) || is_e_function(mf)) {
LispObject allargs,ret;
STACK_TMP(mf);
EUCALLSET_2(allargs, Fn_cons,args,args);
EUCALLSET_2(allargs, Fn_cons,CDR(ml),allargs);
UNSTACK_TMP(mf);
EUCALLSET_2(ret,module_mv_apply_1,mf,allargs);
return ret;
}
if (is_c_function(mf))
{
LispObject ret;
EUCALLSET_2(ret,module_mv_apply_1,mf,args);
return ret;
}
/* if (is_b_function(mf))
{
LispObject *ptr=stackbase;
int i=0;
while (is_cons(args))
{
*ptr=CAR(args);
args=CDR(args);
ptr++;
i++;
}
return(apply_nary_bytefunction(stackbase,i,ml));
}
*/ CallError(stacktop,
"call method: unknown method function class",mf,NONCONTINUABLE);
return(nil);
}
EUFUN_CLOSE
/** accessors and dull stuff **/
static EUFUN_1(Fn_generic_slow_method_cache,gf)
{
return generic_slow_method_cache(gf);
}
EUFUN_CLOSE
static EUFUN_1(Fn_generic_fast_method_cache,gf)
{
return generic_fast_method_cache(gf);
}
EUFUN_CLOSE
static EUFUN_2(Fn_generic_slow_method_cache_setter,gf, value)
{
return generic_slow_method_cache(gf)=value;
}
EUFUN_CLOSE
static EUFUN_2(Fn_generic_fast_method_cache_setter,gf, value)
{
generic_fast_method_cache(gf)=value;
return nil;
}
EUFUN_CLOSE
static EUFUN_1(Fn_generic_name,gf)
{
if (!is_generic(gf))
CallError(stacktop,"generic-method-name: Not a generic",gf,NONCONTINUABLE);
return generic_name(gf);
}
EUFUN_CLOSE
static EUFUN_1(Fn_generic_method_class,gf)
{
if (!is_generic(gf))
CallError(stacktop,"generic-method-class: Not a generic",gf,NONCONTINUABLE);
return generic_method_class(gf);
}
EUFUN_CLOSE
static EUFUN_1(Fn_generic_method_table,gf)
{
if (!is_generic(gf))
CallError(stacktop,"generic-method-table: Not a generic",gf,NONCONTINUABLE);
return generic_method_table(gf);
}
EUFUN_CLOSE
static EUFUN_2(Fn_generic_method_table_setter,gf, value)
{
return generic_method_table(gf)=value;
}
EUFUN_CLOSE
static EUFUN_1(Fn_generic_discriminator,gf)
{
return generic_discriminator(gf);
}
EUFUN_CLOSE
static EUFUN_2(Fn_generic_discriminator_setter,gf, value)
{
return generic_discriminator(gf)=value;
}
EUFUN_CLOSE
/* Method accessors */
static EUFUN_1(Fn_method_signature, meth)
{
return method_signature(meth);
}
EUFUN_CLOSE
/***
** Callback definition...
**/
static LispObject Cb_compute_and_apply_method;
EUFUN_2(compute_and_apply_method, gf, args)
{
LispObject xx;
EUCALLSET_2(xx,Fn_cons,args,nil);
EUCALLSET_2(xx,Fn_cons,ARG_0(stackbase),xx);
stacktop=stackbase;
return EUCALL_2(module_mv_apply_1,CAR(Cb_compute_and_apply_method),xx);
}
EUFUN_CLOSE
EUFUN_1(Fn_set_compute_fn,val)
{
CAR(Cb_compute_and_apply_method)=val;
return nil;
}
EUFUN_CLOSE
/***
** Initialising objects
**
***/
extern MODULE Module_generics;
static
EUFUN_2( Md_allocate_instance_Method_Class, c, args)
{
LispObject ans;
ans = allocate_instance(stacktop,c);
lval_typeof(ans)=TYPE_METHOD;
/* note that we don't need to do this... */
method_qualifier(ans) = nil;
method_signature(ans) = nil;
method_host(ans) = nil;
method_function(ans) = nil;
method_fixed(ans) = nil;
return(ans);
}
EUFUN_CLOSE
static EUFUN_2( Md_initialize_instance_Method, m, args)
{
extern EUDECL(Md_initialize_instance_1);
LispObject fun,sig;
m = EUCALL_2(Md_initialize_instance_1, m,args);
ARG_0(stackbase)=m;
args=ARG_1(stackbase);
if ((fun = search_keylist(stacktop,args,sym_function)) == unbound)
CallError(stacktop,"initialize-instance: missing function initarg for method",
args,NONCONTINUABLE);
args=ARG_1(stackbase);
if ((sig = search_keylist(stacktop,args,sym_signature)) == unbound)
CallError(stacktop,"initialize-instance: missing signature initarg for method",
args,NONCONTINUABLE);
m=ARG_0(stackbase);
method_qualifier(m) = nil;
method_function(m) = fun;
method_host(m) = nil;
method_signature(m) = sig;
return(m);
}
EUFUN_CLOSE
static
EUFUN_2( Md_allocate_instance_Generic_Class, c, args)
{
LispObject ans,nlocal;
ans = allocate_instance(stacktop,c);
lval_typeof(ans)=TYPE_GENERIC;
STACK_TMP(ans);
/* set module, nargs */
generic_home(ARG_2(stackbase)) = (LispObject) &Module_generics;
generic_argtype(ARG_2(stackbase)) = allocate_integer(stacktop,0);
generic_fast_method_cache(ARG_2(stackbase)) = nil;
generic_slow_method_cache(ARG_2(stackbase)) = nil;
generic_method_table(ARG_2(stackbase)) = nil;
/* so that GC won't fall over */
UNSTACK_TMP(ans);
generic_name(ans) = unbound;
generic_method_class(ans) = Method;
generic_discriminator(ans) = nil;
return(ans);
}
EUFUN_CLOSE
static EUFUN_2( Md_initialize_instance_Generic, gf, args)
{
extern EUDECL( Md_initialize_instance_1);
LispObject name,ll,mc,meths,tmp;
LispObject walker;
int code;
gf = EUCALL_2(Md_initialize_instance_1,gf,args);
ARG_0(stackbase)=gf;
args=ARG_1(stackbase);
if ((ll = search_keylist(stacktop,args,sym_lambda_list)) == unbound)
CallError(stacktop,"initialize-instance: missing lambda-list for generic",
args,NONCONTINUABLE);
if ((meths = search_keylist(stacktop,args,sym_methods)) == unbound) meths = nil;
code = 0; walker = ll;
while (is_cons(walker)) {
if (!is_symbol(CAR(walker)))
CallError(stacktop,
"initialize-instance: bad formal in generic lambda-list",
ll,NONCONTINUABLE);
walker = CDR(walker); ++code;
}
if (!is_symbol(walker) && walker != nil)
CallError(stacktop,"initialise-instance: bad generic lambda-list",
ll,NONCONTINUABLE);
if (walker != nil) code = -1-code;
STACK_TMP(meths);
if ((name = search_keylist(stacktop,ARG_1(stackbase),sym_name)) == unbound) name = unbound;
generic_name(gf) = name;
generic_argtype(gf) = allocate_integer(stacktop,code);
gf=ARG_0(stackbase);
if ((mc = search_keylist(stacktop,ARG_1(stackbase),sym_method_class)) == unbound)
CallError(stacktop,"initialize-instance: missing method-class for generic",
ARG_1(stackbase),NONCONTINUABLE);
generic_method_class(gf) = mc;
tmp= generic_apply_1(stacktop,generic_compute_discriminating_function,gf);
gf=ARG_0(stackbase);
generic_discriminator(gf)=tmp;
/* Install the methods... */
UNSTACK_TMP(meths);
gf=ARG_0(stackbase);
walker = meths;
while (is_cons(walker)) {
STACK_TMP(CDR(walker));
generic_apply_2(stacktop,generic_add_method,gf,CAR(walker));
gf=ARG_0(stackbase);
UNSTACK_TMP(walker);
}
return(gf);
}
EUFUN_CLOSE
/* Initialisation of the module */
#define GENERICS_ENTRIES 21
MODULE Module_generics;
LispObject Module_generics_values[GENERICS_ENTRIES];
void initialise_generics(LispObject *stacktop)
{
Cb_compute_and_apply_method=EUCALL_2(Fn_cons,nil,nil);
add_root(&Cb_compute_and_apply_method);
method_args_handle = get_symbol(stacktop,"***method-args-handle***");
add_root(&method_args_handle);
method_status_handle = get_symbol(stacktop,"***method-status-handle***");
add_root(&method_status_handle);
sym_signature = get_symbol(stacktop,"signature");
add_root(&sym_signature);
sym_qualifiers = get_symbol(stacktop,"qualifiers");
add_root(&sym_qualifiers);
sym_lambda_list = get_symbol(stacktop,"lambda-list");
add_root(&sym_lambda_list);
sym_method_class = get_symbol(stacktop,"method-class");
add_root(&sym_method_class);
open_module(stacktop,
&Module_generics,
Module_generics_values,
"generics",
GENERICS_ENTRIES);
generic_compute_discriminating_function =
make_module_generic(stacktop,"compute-discriminating-function", 1);
add_root(&generic_compute_discriminating_function);
(void) make_module_function(stacktop,"generic-function-p",Fn_generic_function_p,1);
(void) make_module_function(stacktop,"methodp",Fn_methodp,1);
/* Randomised accessors */
(void) make_module_function(stacktop,"generic-slow-method-cache",Fn_generic_slow_method_cache,1);
(void) make_module_function(stacktop,"generic-fast-method-cache",Fn_generic_fast_method_cache,1);
(void) make_module_function(stacktop,"generic-method-table",Fn_generic_method_table,1);
(void) make_module_function(stacktop,"generic-slow-method-cache-setter",
Fn_generic_slow_method_cache_setter,2);
(void) make_module_function(stacktop,"generic-fast-method-cache-setter",
Fn_generic_fast_method_cache_setter,2);
(void) make_module_function(stacktop,"generic-method-table-setter",
Fn_generic_method_table_setter,2);
(void) make_module_function(stacktop,"generic-discriminator",Fn_generic_discriminator,1);
(void) make_module_function(stacktop,"generic-discriminator-setter",
Fn_generic_discriminator_setter,2);
(void) make_module_function(stacktop,"generic-name",Fn_generic_name,1);
(void) make_module_function(stacktop,"generic-function-method-class",Fn_generic_method_class,1);
(void) make_module_function(stacktop,"method-signature",Fn_method_signature,1);
(void) make_module_function(stacktop,"set-compute-and-apply-fn",Fn_set_compute_fn,1);
(void) make_module_function(stacktop,"call-method-by-list",call_method_by_list,2);
/* add method */
generic_add_method=make_module_generic(stacktop,"add-method",2);
add_root(&generic_add_method);
/* Making the things... */
(void) make_module_function(stacktop,"generic_allocate_instance,Method_Class",
Md_allocate_instance_Method_Class,2);
(void) make_module_function(stacktop,"generic_initialize_instance,Method",
Md_initialize_instance_Method,2);
(void) make_module_function(stacktop,"generic_allocate_instance,Generic_Class",
Md_allocate_instance_Generic_Class,
2);
(void) make_module_function(stacktop,"generic_initialize_instance,Generic",
Md_initialize_instance_Generic,2);
close_module();
}
#if 0 /* GENERIC LOOKUP WITH 1st ARG SWITCHING --- case not proven */
/* then the slow cache */
{ tmp=generic_slow_method_cache(gf);
ptr=tmp;
while(ptr!=nil && CAR(CAR(ptr))!=classof(*stackbase))
ptr=CDR(ptr);
if (ptr!=nil)
{
LispObject tmp2;
tmp2=CAR(tmp);
CAR(tmp)=CAR(ptr);
CAR(ptr)=tmp2;
ptr=CDR(CAR(tmp));
walker=stackbase+1;
count=1;
while(ptr!=nil && count<explicit)
{
if (CAR(CAR(ptr))==classof(*(walker)))
{ /* move down 1 */
ptr=CDR(CAR(ptr));
walker++;
count++;
}
else
ptr=CDR(ptr);
}
if (count==explicit)
{
generic_fast_method_cache(gf)=ptr;
return(call_method(stackbase,nargs,CDR(ptr)));
}
}
/* not in slow cache */
}
#endif